!-------------------------------------------------------------LICENSE--------------------------------------------------------------!
!                                                                                                                                  !
!The MAP code is written in Fortran language for magnetohydrodynamics (MHD) calculation with the adaptive mesh refinement (AMR)    !
!and Message Passing Interface (MPI) parallelization.                                                                              !
!                                                                                                                                  !
!Copyright (C) 2012                                                                                                                !
!Ronglin Jiang                                                                                                                     !
!rljiang@ssc.net.cn                                                                                                                !
!585 Guoshoujing Road. Pudong, Shanghai, P.R.C. 201203                                                                             !
!                                                                                                                                  !
!This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License         !
!as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.             !
!                                                                                                                                  !
!This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of    !
!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.                        !
!                                                                                                                                  !
!You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software     !
!Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.                                                   !
!                                                                                                                                  !
!-------------------------------------------------------------LICENSE--------------------------------------------------------------!

!==================================================================================================================================|
subroutine framework_sync (base)
!==================================================================================================================================|

   use parameters
   use block_define
   use interface_block_generate
   use interface_block_destroy
   use interface_hilbert_curve
   implicit none

   type(block), pointer, intent(in) :: base

   integer(4) :: i_cpu, i_neigh, j_neigh, k_neigh, i_block, j_block, k_block, pos_x, pos_y, pos_z
   integer(4) :: tmp_i_gene, destroy_flag, n_blocks_destroy, n_gene_tmp, i_level
   integer(4), dimension(n_dims, n_levels, i_gene(cpu_id_p1)) :: gene_cpu
   integer(4), dimension(cpu_number) :: gene_offset
   integer(4), dimension(:, :, :), allocatable :: gene_tmp
   integer(4), dimension(:, :, :), allocatable :: blocks_id_check
   integer(4), dimension(:, :, :, :), allocatable :: blocks_id_all_check
   type(block), pointer :: current, child, neigh, next, framework_next, pointer_tmp

!----------------------------------------------------------------------------------------------------------------------------------|
!  framework reset
!----------------------------------------------------------------------------------------------------------------------------------|
   do i_level = max_level, 2, -1
      current => base%framework_next

      do while (current%lv .ne. 0)
         if (current%hilbert_number .eq. 0 .and. current%lv .eq. i_level) then
            n_blocks_destroy = 0
            current => current%parent
            next => current%framework_next
            do while (next%lv .gt. current%lv)
               if (next%cpu_id .eq. cpu_id) n_blocks_destroy = n_blocks_destroy + 1
               next => next%framework_next
            enddo

            next%framework_last => current
            current%framework_next => next

            if (current%cpu_id .eq. cpu_id) then
               if (next%cpu_id .eq. cpu_id) then
                  next%last => current
                  current%next => next
               else
                  base%last => current
                  current%next => base
               endif
            else
               if (next%cpu_id .eq. cpu_id) then
                  if (next%lv .ne. 0) then
                     next%last => base
                     base%next => next
                  endif
               else
                  if (n_blocks_destroy .ne. 0) then
                     base%next => base
                     base%last => base
                  endif
               endif
            endif

            call block_destroy(current, 0)
         endif
         current => current%framework_next
      enddo
   enddo

!----------------------------------------------------------------------------------------------------------------------------------|
!  synchronization check
!----------------------------------------------------------------------------------------------------------------------------------|
   if (syn_check_flag .eq. 1) then
      allocate (blocks_id_check(n_dims, n_levels, n_blocks_all), blocks_id_all_check(n_dims, n_levels, n_blocks_all, cpu_number))

      blocks_id_check = 0
      blocks_id_all_check = 0

      i_block = 0
      current => base%framework_next
      do while (current%lv .ne. 0)
         do k_neigh = -1, 1
         do j_neigh = -1, 1
         do i_neigh = -1, 1
            neigh => current%neigh(i_neigh, j_neigh, k_neigh)%pblock
            if (.not. associated (neigh)) then
               if (current%id(1, 1) .eq. 1 .and. i_neigh .eq. -1) then
                  cycle
               elseif (current%id(1, 1) .eq. ini_block_x .and. i_neigh .eq. 1) then
                  cycle
               elseif (current%id(2, 1) .eq. 1 .and. j_neigh .eq. -1) then
                  cycle
               elseif (current%id(2, 1) .eq. ini_block_y .and. j_neigh .eq. 1) then
                  cycle
               elseif (current%id(3, 1) .eq. 1 .and. k_neigh .eq. -1) then
                  cycle
               elseif (current%id(3, 1) .eq. ini_block_z .and. k_neigh .eq. 1) then
                  cycle
               else
                  write (*, *)
                  write (*, '(a)') ' Error: links error.'
                  write (*, '(a)') ' CPU id: ', cpu_id
                  write (*, '(a)') ' Current block id: ', current%id
                  write (*, '(a)') ' The program will be terminated.'
                  write (*, *)
                  call mpi_abort (mpi_comm_world, 1, error)
               endif
            endif
            if (neigh%lv .le. 0) cycle
            if (abs (neigh%lv - current%lv .gt. 1)) then
               write (*, *)
               write (*, '(a)') ' Error: the level difference between neighbor and current block is too large.'
               write (*, '(a)') ' CPU id: ', cpu_id
               write (*, '(a)') ' Current block id: ', current%id
               write (*, '(a)') ' The program will be terminated.'
               write (*, *)
               call mpi_abort (mpi_comm_world, 1, error)
            endif
         enddo
         enddo
         enddo
         i_block = i_block + 1
         blocks_id_check(:, :, i_block) = current%id
         current => current%framework_next
      enddo

      call mpi_allgather (blocks_id_check, n_dims * n_levels * n_blocks_all, mpi_integer4,                                            &
         blocks_id_all_check, n_dims * n_levels * n_blocks_all, mpi_integer4, mpi_comm_world, error)

      do i_cpu = 0, cpu_number - 1
         if (i_cpu .eq. cpu_id) cycle
         if (any (blocks_id_all_check(:, :, :, i_cpu + 1) .ne. blocks_id_all_check(:, :, :, cpu_id_p1))) then
            write (*, *)
            write (*, '(a)') ' Error: the frameworks in different cpu are not synchronized.'
            write (*, *) 'CPU id: ', cpu_id
            write (*, '(a)') ' The program will be terminated.'
            write (*, *)
            call mpi_abort (mpi_comm_world, 1, error)
         endif
      enddo

      deallocate (blocks_id_check, blocks_id_all_check)
   endif

!----------------------------------------------------------------------------------------------------------------------------------|
!  collect the gene information
!----------------------------------------------------------------------------------------------------------------------------------|
   tmp_i_gene = i_gene(cpu_id_p1)

   call mpi_allgather (tmp_i_gene, 1, mpi_integer4, i_gene, 1, mpi_integer4, mpi_comm_world, error)

   if (sum(i_gene) .gt. n_gene) then
      allocate(gene_tmp(n_dims, n_levels, n_gene))
      gene_tmp = gene
      n_gene_tmp = n_gene
      n_gene = sum(i_gene)
      deallocate(gene)
      allocate(gene(n_dims, n_levels, n_gene))
      gene(:, :, 1 : n_gene_tmp) = gene_tmp
      deallocate(gene_tmp)
   endif

   gene_cpu = gene

   gene_offset = 0
   do i_cpu = 2, cpu_number
      gene_offset(i_cpu) = i_gene(i_cpu - 1) * n_dims * n_levels + gene_offset(i_cpu - 1)
   enddo

   call mpi_allgatherv (gene_cpu, i_gene(cpu_id_p1) * n_dims * n_levels, mpi_integer4,                                             &
      gene, i_gene * n_dims * n_levels, gene_offset, mpi_integer4, mpi_comm_world, error)

!----------------------------------------------------------------------------------------------------------------------------------|
!  block generate and destroy
!----------------------------------------------------------------------------------------------------------------------------------|
   loop: do tmp_i_gene = 1, sum(i_gene)
      current => base
      i_level = 1
      do while (gene(1, i_level, tmp_i_gene) .ne. 0)
         if (.not. associated (current%child)) cycle loop
         pos_x = abs (gene(1, i_level, tmp_i_gene))
         pos_y = abs (gene(2, i_level, tmp_i_gene))
         pos_z = abs (gene(3, i_level, tmp_i_gene))
         current => current%child(pos_x, pos_y, pos_z)%pblock
         i_level = i_level + 1
         if (i_level .gt. n_levels) exit
      enddo

      if (gene(1, 1, tmp_i_gene) .gt. 0 .and. current%nc .eq. 0 .and. current%lv .lt. n_levels) then
         if (current%lv .lt. n_levels) then
            call block_generate (current, current%cpu_id)
            next => current%next
            framework_next => current%framework_next
            pointer_tmp => current

            call hilbert_curve(current, pointer_tmp, current%parent_cell, current%hilbert_pos, 1, (/1, 1, 1/), current%cpu_id)

            if (current%cpu_id .eq. cpu_id) then
               next%last => pointer_tmp
               pointer_tmp%next => next
            endif

            framework_next%framework_last => pointer_tmp
            pointer_tmp%framework_next => framework_next
         endif

      elseif (gene(1, 1, tmp_i_gene) .lt. 0 .and. current%nc .ne. 0) then

         destroy_flag = 1

         do k_block = 1, current%nc_z
         do j_block = 1, current%nc_y
         do i_block = 1, current%nc_x
            child => current%child(i_block, j_block, k_block)%pblock
            do k_neigh = -1, 1
            do j_neigh = -1, 1
            do i_neigh = -1, 1
               neigh => child%neigh(i_neigh, j_neigh, k_neigh)%pblock
               if (associated(neigh)) then
                  if (all(neigh%parent%id .eq. child%parent%id)) cycle
                  if (neigh%lv .eq. child%lv .and. neigh%nc .ne. 0) destroy_flag = 0
               endif
            enddo
            enddo
            enddo
         enddo
         enddo
         enddo

         if (destroy_flag .eq. 1) then
            n_blocks_destroy = 0

!----------------------------------------------------------------------------------------------------------------------------------|
!           count the number of destroyed blocks which are belong to current cpu
!----------------------------------------------------------------------------------------------------------------------------------|
            next => current%framework_next
            do while (next%lv .gt. current%lv)
               if (next%cpu_id .eq. cpu_id) n_blocks_destroy = n_blocks_destroy + 1
               next => next%framework_next
            enddo
            next%framework_last => current
            current%framework_next => next

            if (current%cpu_id .eq. cpu_id) then
               if (next%cpu_id .eq. cpu_id) then
                  next%last => current
                  current%next => next
               else
                  base%last => current
                  current%next => base
               endif
            else
               if (next%cpu_id .eq. cpu_id) then
                  if (next%lv .ne. 0) then
                     next%last => base
                     base%next => next
                  endif
               else
                  if (n_blocks_destroy .ne. 0) then
                     base%next => base
                     base%last => base
                  endif
               endif
            endif

            call block_destroy(current, n_blocks_destroy)
         endif
      endif
      current => current%framework_next
   enddo loop

!----------------------------------------------------------------------------------------------------------------------------------|
!  calculation the total number of the blocks and update the n_blocks
!----------------------------------------------------------------------------------------------------------------------------------|
   call mpi_allreduce(n_blocks(cpu_id_p1), n_blocks_all, 1, mpi_integer4, mpi_sum, mpi_comm_world, error)
   i_block = n_blocks(cpu_id_p1)
   call mpi_allgather(i_block, 1, mpi_integer4, n_blocks, 1, mpi_integer4, mpi_comm_world, error)

!----------------------------------------------------------------------------------------------------------------------------------|
   return
end subroutine framework_sync
